home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / ilisp / lucid.lisp.z / lucid.lisp
Encoding:
Text File  |  1998-05-21  |  2.6 KB  |  87 lines
  1. ;;; -*- Mode: Lisp -*-
  2.  
  3. ;;; lucid.lisp --
  4.  
  5. ;;; This file is part of ILISP.
  6. ;;; Version: 5.8
  7. ;;;
  8. ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
  9. ;;;               1993, 1994 Ivan Vasquez
  10. ;;;               1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker
  11. ;;;               1996 Marco Antoniotti and Rick Campbell
  12. ;;;
  13. ;;; Other authors' names for which this Copyright notice also holds
  14. ;;; may appear later in this file.
  15. ;;;
  16. ;;; Send mail to 'ilisp-request@naggum.no' to be included in the
  17. ;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP
  18. ;;; mailing list were bugs and improvements are discussed.
  19. ;;;
  20. ;;; ILISP is freely redistributable under the terms found in the file
  21. ;;; COPYING.
  22.  
  23.  
  24.  
  25. ;;; Lucid initializations 
  26. ;;; Author: Chris McConnell, ccm@cs.cmu.edu
  27. ;;;
  28. (in-package "ILISP")
  29.  
  30. ;;;
  31. (defun ilisp-callers (symbol package &aux (list-of-callers nil))
  32.   "Print the callers of PACKAGE::SYMBOL.  Only compiled functions
  33. currently.  Return T if successful."
  34.   (ilisp-errors
  35.    (let ((function-name (ilisp-find-symbol symbol package))
  36.      (*print-level* nil)
  37.      (*print-length* nil)
  38.      (*package* (find-package 'lisp)))
  39.      (when (and function-name (fboundp function-name))
  40.        (flet
  41.        ((check-symbol (symbol)
  42.           (labels
  43.           ((check-function (function &optional exclusions)
  44.              (do ((i 4 (1+ i)))
  45.              ((>= i (lucid::procedure-length function)))
  46.                (let ((element (sys:procedure-ref function i)))
  47.              (cond ((eq element function-name)
  48.                 (pushnew symbol list-of-callers))
  49.                    ((and (compiled-function-p element)
  50.                      (not (find element exclusions)))
  51.                 (check-function
  52.                  element
  53.                  (cons element exclusions))))))))
  54.         (check-function (symbol-function symbol)))))
  55.      (do-all-symbols (symbol)
  56.        (when (fboundp symbol)
  57.          (check-symbol symbol)))
  58.      (dolist (caller list-of-callers)
  59.        (print caller))
  60.      t)))))
  61.  
  62. ;;;
  63. (defun ilisp-source-files (symbol package type)
  64.   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  65. return T if successful."
  66.   (ilisp-errors
  67.    (let* ((symbol (ilisp-find-symbol symbol package))
  68.       (all (equal type "any"))
  69.       (type (unless all (ilisp-find-symbol type package)))
  70.       (paths (when symbol
  71.            (lucid::get-source-file symbol type all))))
  72.      (if paths
  73.      (progn
  74.        (if all
  75.            (dolist (file (remove-duplicates paths
  76.                         :key #'cdr :test #'equal))
  77.          (print (namestring (cdr file))))
  78.            (print (namestring paths)))
  79.        t)
  80.      nil))))
  81.  
  82. ;;;
  83. (dolist (symbol '(ilisp-callers ilisp-source-files))
  84.   (export symbol))
  85. (unless (compiled-function-p #'ilisp-callers)
  86.   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  87.